home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
MATH
/
PMAT12
/
PMAT.EXE
/
MATTEST2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-12-09
|
7KB
|
226 lines
Program pt;
Uses pmat;
Procedure recursion;
Var vv,a,b: vmatrixptr;
Begin
new( vv, makematrix( 1, 1 ) );
new( a, makematrix( 1, 1 ) );
new( b, makematrix( 1, 1 ) );
vv := matequals( vv, inv( add( ident( 5 ), fill( 5, 5, 1 ) ) ) );
vv^.show( 'Inv(I+U)' );
dispose( vv, killvmatrix );
dispose( a, killvmatrix );
dispose( b, killvmatrix );
End;
Procedure regression;
Var x,y,data,beta,xpx : vmatrixptr;
Begin
new( x, makematrix( 1, 1 ) );
new( y, makematrix( 1, 1 ) );
new( data, makematrix( 1, 1 ) );
new( beta, makematrix( 1, 1 ) );
new( xpx, makematrix( 1, 1 ) );
data := matequals( data, reada( 'catchv.dat' ) );
y := matequals( y, submat( data, 1, data^.r, 1, 1 ) );
x := matequals( x, submat( data, 1, data^.r, 2, data^.c ) );
beta := matequals( beta, mult( inv( mult( tran( x ), x ) ), mult( tran( x ), y ) ) );
beta^.show( 'text book beta hat' );
xpx := matequals( xpx, mult( tran( data ), data ) );
xpx := matequals( xpx, sweep( xpx, 2, xpx^.r ) );
beta := matequals( beta, submat( xpx, 2, xpx^.r, 1, 1 ) );
beta^.show( 'sweep beta hat' );
dispose( x, killvmatrix );
dispose( y, killvmatrix );
dispose( data, killvmatrix );
dispose( beta, killvmatrix );
dispose( xpx, killvmatrix );
End;
Procedure testIO;
Var vv : vmatrixptr;
Begin
new( vv, makematrix( 1, 1 ) );
vv := matequals( vv, reada( 'catchv.dat' ) );
vv^.show( 'catchv.dat' );
writea( 'junk.dat', vv , 'junk.dat' );
vv := matequals( vv, reada( 'junk.dat' ) );
vv^.show( 'junk.dat' );
dispose( vv, killvmatrix );
End;
Procedure testElements;
Var vv: vmatrixptr;
d : double;
i,j: integer;
Begin
{ note ^ must follow a call to mm, but not to m }
new( vv, makematrix( 5, 5 ) );
vv := matequals( vv, fill( 5, 5, 0 ) );
d := 0;
For i := 1 To vv^.r Do Begin
For j := 1 To vv^.c Do Begin
d := d + 1;
vv^.mm( i, j )^ := d;
End;
End;
vv^.mm( 3, 3 )^ := 3;
vv^.show( 'vv' );
writeln( '4,5 element of vv: ', vv^.m( 4, 5 ): 6: 2 );
dispose( vv, killvmatrix );
End;
Procedure ObjectQuirk;
Var vv : vmatrixptr;
Begin
new( vv, makematrix( 1, 1 ) );
fill( 3, 3, 1 )^.show( ' silly ' );
{ weird but ok }
dispatch^.dumpstack;
vv := matequals( vv, fill( 5, 5, 3 ) );
{take the fill 3,3 off of stack}
dispatch^.dumpstack; { using cleanstack in matequals}
vv^.show( 'vv' );
dispose( vv, killvmatrix );
End;
Procedure testleak( Var vv: vmatrixptr );
Var ones,jj : vmatrixptr;
i : integer;
Begin
{this function should cause a memory error if there is a leak}
dispatch^.inclevel;
writeln( 'this can take a while' );
writeln( 'MemAvail, MaxAvail 1 : ', memavail, ' ', maxavail );
new( ones, makematrix( 1, 1 ) );
new( jj, makematrix( 1, 1 ) );
ones := matequals( ones, fill( vv^.r, vv^.c, 1 ) );
jj := matequals( jj, vv );
For i := 1 To 1000 Do
jj := matequals( jj, add( jj, mult( tran( ones ), ones ) ) );
vv := matequals( vv, jj );
dispose( ones, killvmatrix );
dispose( jj, killvmatrix );
writeln( 'MemAvail, MaxAvail 2 : ', memavail, ' ', maxavail );
dispatch^.declevel;
End;
Function testDecReturn: vmatrixptr;
Var b: vmatrixptr;
Begin
{ use inclevel and decreturn if you use matequals in a function}
{ also use inclevel-declevel in procedures that use matequals, or
in functions that use matequals but do not return vmatrixptr's.}
Dispatch^.Inclevel;
new( b, makematrix( 5, 5 ) );
b := matequals( b, Inv( add( Ident( 5 ), fill( 5, 5, 1 ) ) ) );
dispatch^.push( b );
testDecReturn := Dispatch^.decreturn;
End;
Function testReturnMat: vmatrixptr;
Var b: vmatrixptr;
i,j : integer;
d : double;
Begin
{ use returnmat if you do not use matequals in a function}
new( b, makematrix( 5, 5 ) );
d := 0;
For i := 1 To 5 Do
For j := 1 To 5 Do Begin
d := d + 1;
b^.mm( i, j )^ := d;
End;
dispatch^.push( b );
testReturnMat := Dispatch^.ReturnMat;
End;
Procedure testfuncts;
Var i,u,v: vmatrixptr;
k : integer;
Begin
new( i, makematrix( 5, 5 ) );
new( u, makematrix( 5, 5 ) );
new( v, makematrix( 5, 5 ) );
i := matequals( i, Ident( 5 ) );
u := matequals( u, Fill( 5, 5, 1 ) );
v := matequals( v, emult( i, u ) );
v^.show( 'I#U' );
v := matequals( v, neg( u ) );
v^.show( '-U' );
v := matequals( v, cv( i, u ) );
v^.show( 'i//v' );
v := matequals( v, ch( i, u ) );
v^.show( 'i||u' );
v := matequals( v, msqrt( add( i, u ) ) );
v^.show( 'sqrt(i+u)' );
v := matequals( v, fill( 5, 1, 0 ) );
For k := 1 To v^.r Do v^.mm( k, 1 )^ := k;
v := matequals( v, vecdiag( v ) );
v^.show( 'vecdiag(v)' );
v := matequals( v, fill( 1, 5, 0 ) );
For k := 1 To v^.c Do v^.mm( 1, k )^ := k;
v := matequals( v, vecdiag( v ) );
v^.show( 'vecdiag(v)' );
dispose( i, killvmatrix );
dispose( u, killvmatrix );
dispose( v, killvmatrix );
End;
Procedure testPass( Var x: vmatrixptr );
Begin
x := matequals( x, ident( 3 ) );
End;
{main}
Var
vv, a, b: vmatrixptr;
Begin
new( vv, makematrix( 128, 128 ) );{make matrix > 64k}
vv^.infomatrix( 'vv' );
recursion; { test recursive calls }
regression; { test regression }
testIO; { test matrix io }
testElements; { test element functions }
{ something I consider weird about OOP }
ObjectQuirk;
{ test for memory leak and var parameter passing }
vv := matequals( vv, fill( 5, 5, 0 ) );
testLeak( vv );
vv^.show( 'vv as a var parameter' );
{ show difference between DecReturn and ReturnMat }
vv := matequals( vv, testDecReturn );
vv^.show( 'vv from testDecReturn' );
vv := matequals( vv, testReturnMat );
vv^.show( 'vv from testReturnMat' );
dispose( vv, killvmatrix );
vv^.infomatrix( 'vv after dispose' );
{ Test Matrix functions }
TestFuncts;
testPass( vv );
vv^.show( 'after pass' );
{$IFDEF DPMI}
writeln('make a matrix larger than 640k');
vv := matequals( vv, fill(300,300, 0 ) );
vv^.infomatrix('matrix larger than 640k');
{$ENDIF}
End.